home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / s4th68k.arc / SFORTH.68K
Text File  |  1987-11-08  |  43KB  |  2,225 lines
  1. ;
  2. ; Sforth for the 68000.
  3. ;
  4. ; Created by Alan DeMars, Scorpion Softworks, 1/1/87.
  5. ;
  6. ; The FORTH processor has been eliminated. All calls to FORTH words
  7. ; are done explicitly with JSR's.
  8. ;
  9. ; The standard FIG FORTH word headers have been retained.
  10. ;
  11. ; The 'COMPILE' command compiles 3 words. The 1st
  12. ; word is always '4EB9' ( JSR ) the last 2 are the absolute address.
  13. ;
  14. ; The SMUDGE bit has been replaced by the MACRO bit. If set, the word's
  15. ; code is copied into new word definitions (instead of compiling a JSR
  16. ; to the CFA). Use like IMMEDIATE. Just write MACRO immediately after a
  17. ; word's definition if you want its code to be copied inline to a new
  18. ; word's code field. Everything up to the 'RTS' ($4E75) gets copied.
  19. ;
  20. ; Anyone is welcome to use this program for any purpose they like.
  21. ; However, it would be a great ego boost if you would reference my name
  22. ; in your application somewhere (and send me $20.00 for my troubles if
  23. ; you feel guilty about getting something for next to nothing).
  24. ;
  25. ; Also, if you make any modifications like fix any bugs you find or add
  26. ; any neat features or if you have any suggestions at all please let me
  27. ; know what they are so I can take advantage of your efforts.
  28. ;
  29. ; My Address:
  30. ;        335 South 'H' Street
  31. ;        Lompoc, California, 93436
  32. ;
  33. ; I can be reached at (805) 735-1595 between 5pm and 8pm PST.
  34. ;
  35. ; One more thing: Sforth for the 6809 is also available if you have
  36. ; any interest.
  37. ;
  38.  
  39.     far code
  40.     far data
  41.  
  42. ;
  43. ;    MACROS for creating dictionary headers
  44. ;
  45. ;    The assembler I'm using doesn't have a SET directive so I can't
  46. ;    thread the words together with the WORDM macro. Instead I compile
  47. ;    a (unique) long word of $ad55ad55 in the link field of each header
  48. ;    and thread the words together at cold start.
  49. ;
  50.  
  51. ;    for single character words
  52.  
  53.     MACRO    WORDM1
  54.     dc.b    $81,$80+'%3'
  55.     dc.l    $ad55ad55
  56.     ENDM
  57.  
  58. ;    for multiple character words
  59.  
  60.     MACRO    WORDMX
  61.     dc.b    $80+%1,"%2",$80+'%3'
  62.     dc.l    $ad55ad55
  63.     ENDM
  64.  
  65. ;    for single character immediate words
  66.  
  67.     MACRO    WORDMI1
  68.     dc.b    $C1,$80+'%3'
  69.     dc.l    $ad55ad55
  70.     ENDM
  71.  
  72. ;    for multiple character immediate words
  73.  
  74.     MACRO    WORDMIX
  75.     dc.b    $C0+%1,"%2",$80+'%3'
  76.     dc.l    $ad55ad55
  77.     ENDM
  78.  
  79. ;    for single character MACRO words
  80.  
  81.     MACRO    WORDMM1
  82.     dc.b    $A1,$80+'%3'
  83.     dc.l    $ad55ad55
  84.     ENDM
  85.  
  86. ;    for multiple character MACRO words
  87.  
  88.     MACRO    WORDMMX
  89.     dc.b    $A0+%1,"%2",$80+'%3'
  90.     dc.l    $ad55ad55
  91.     ENDM
  92.  
  93. ;    for USER variables
  94.  
  95.     MACRO    WORDMU
  96.     dc.b    $80+%1,"%2",$80+'%3'
  97.     dc.l    $ad55ad55
  98. %4    JSR    DOUSER
  99.     dc.l    %5-UBEGIN
  100.     ENDM
  101.  
  102.  
  103. ;
  104. ;  THE DO MACROS
  105. ;
  106. ;  These Macros simply make a long list of JSR's easier to write
  107. ;  by allowing you to write all the calls on one line.
  108. ;
  109. ;   Example:
  110. ;
  111. ;    DO4    LIST,PFIND,ENCLOS,QUIT
  112. ;
  113. ;   Which would expand to:
  114. ;
  115. ;    JSR LIST-START(a4)
  116. ;    JSR PFIND-START(a4)
  117. ;    JSR ENCLOS-START(a4)
  118. ;    JSR QUIT-START(a4)
  119. ;
  120. ;  They do tend to slow up the assembly process though.
  121. ;
  122. ;  All words within the kernel use a4 relative addressing to save room.
  123. ;  All words defined outside the kernel use 32 bit absolute addressing.
  124. ;
  125.  
  126.     MACRO    DO1
  127.     JSR    %1-START(a4)
  128.     ENDM
  129.  
  130.     MACRO    DO2
  131.     JSR    %1-START(a4)
  132.     JSR    %2-START(a4)
  133.     ENDM
  134.  
  135.     MACRO    DO3
  136.     JSR    %1-START(a4)
  137.     JSR    %2-START(a4)
  138.     JSR    %3-START(a4)
  139.     ENDM
  140.  
  141.     MACRO    DO4
  142.     JSR    %1-START(a4)
  143.     JSR    %2-START(a4)
  144.     JSR    %3-START(a4)
  145.     JSR    %4-START(a4)
  146.     ENDM
  147.  
  148.     MACRO    DO5
  149.     JSR    %1-START(a4)
  150.     JSR    %2-START(a4)
  151.     JSR    %3-START(a4)
  152.     JSR    %4-START(a4)
  153.     JSR    %5-START(a4)
  154.     ENDM
  155.  
  156.     MACRO    DO6
  157.     JSR    %1-START(a4)    
  158.     JSR    %2-START(a4)
  159.     JSR    %3-START(a4)
  160.     JSR    %4-START(a4)
  161.     JSR    %5-START(a4)
  162.     JSR    %6-START(a4)
  163.     ENDM
  164.  
  165.     MACRO    DO7
  166.     JSR    %1-START(a4)    
  167.     JSR    %2-START(a4)
  168.     JSR    %3-START(a4)
  169.     JSR    %4-START(a4)
  170.     JSR    %5-START(a4)
  171.     JSR    %6-START(a4)
  172.     JSR    %7-START(a4)
  173.     ENDM
  174.  
  175.     MACRO    DO8
  176.     JSR    %1-START(a4)
  177.     JSR    %2-START(a4)
  178.     JSR    %3-START(a4)
  179.     JSR    %4-START(a4)
  180.     JSR    %5-START(a4)
  181.     JSR    %6-START(a4)
  182.     JSR    %7-START(a4)
  183.     JSR    %8-START(a4)
  184.     ENDM
  185.  
  186.     MACRO    DO9
  187.     JSR    %1-START(a4)
  188.     JSR    %2-START(a4)
  189.     JSR    %3-START(a4)
  190.     JSR    %4-START(a4)
  191.     JSR    %5-START(a4)
  192.     JSR    %6-START(a4)
  193.     JSR    %7-START(a4)
  194.     JSR    %8-START(a4)
  195.     JSR    %9-START(a4)
  196.     ENDM
  197.  
  198.     MACRO    DOX
  199.     JMP    %1-START(a4)
  200.     ENDM
  201.  
  202. ;
  203. ;    Start of user variables.
  204. ;
  205. ;    Some of the next stuff is initialized during COLD and WARM
  206. ;    starts.  Names correspond to FORTH words of similar (no X)
  207. ;    name.
  208.  
  209. ;    below initialized on cold start
  210.  
  211.     bss    UBEGIN,0    start of user variables
  212.     bss    XFENCE,4    fence for FORGET
  213.     bss    XDP,4        dictionary pointer
  214.     bss    XVOCL,4        vocabulary listing
  215.     bss    XEFUNC,4    address of EFUNC driver
  216.     bss    XDELAY,4    carriage return delay count (# nulls)
  217.     bss    XCOLUM,4    carriage width
  218.     bss    XBLK,4        disc block being accessed
  219.     bss    XIN,4        scan pointer into the block
  220.     bss    XOUT,4        cursor positionx
  221.     bss    XSCR,4        disc screen being accessed (0=terminal)
  222.     bss    XOFSET,4    disc sector offset for multi-disc
  223.     bss    XCONT,4        last word in primary search vocabulary
  224.     bss    XCURR,4        last word in extensible vocabulary
  225.     bss    XSTATE,4    flag for 'interpret' or 'compile' modes
  226.     bss    XBASE,4        number base for i/o numeric conversioTE
  227.     bss    XDPL,4        decimal point place
  228.     bss    XFLD,4
  229.     bss    XCSP,4        current stack position, for compile checks
  230.     bss    XRNUM,4
  231.     bss    XHLD,4
  232.  
  233. ; init below on cold or warm
  234.  
  235.     bss    XSPZER,4    initial top of data stack for this user
  236.     bss    XTIB,4        start of terminal input buffer
  237.     bss    XRZERO,4    initial top of return stack
  238.     bss    XFINA,4        address of input file FCB
  239.     bss    XFOUTA,4    address of output file FCB
  240.     bss    XWIDTH,4    name file width
  241.     bss    XMSGBS,4    Base SCReen number for messages and GO
  242.     bss    XWARN,4        warning message mode (0=no disc)
  243.     bss    XQUIET,4    echo flag during downloads
  244.     bss    XIRQV,4        redirectable IRQ vector
  245.     bss    XFIRQV,4    redirectable FIRQ vector
  246.     bss    XNMIV,4        redirectable NMI vector
  247.     bss    XSWIV,4        redirectable SWI vector
  248.     bss    XSWI2V,4    redirectable SWI2 vector
  249.     bss    XSWI3V,4    redirectable SWI3 vector
  250.     bss    XUVPTR,4    User variable pointer
  251.     bss    XBOOTV,4    User boot word's CFA
  252.     bss    XEMIT,4        Redirectable EMIT
  253.     bss    XKEY,4        Redirectable KEY
  254.     bss    XQTERM,4    Redirectable ?TERMINAL
  255.     bss    RETURN,4    a7 address at start up
  256.  
  257. ; end of user table
  258.  
  259. ;
  260. ; Beginning of variable dictionary entries
  261. ;
  262.  
  263.     bss    FORTHS,10
  264.     bss    FORTH,16
  265.     bss    TASKAA,12
  266.  
  267. ;FORTHS    dc.b    $C5,"FORT",$80+'H'    ; (6 bytes)
  268. ;    dc.l    NOOP-10            ; LINK "BACK" (4 bytes)
  269. ;FORTH    DO1    DODOES            ; (4 bytes)
  270. ;    dc.l    DOVOC            ; (4 bytes)
  271. ;    dc.w    $81A0            ; (2 bytes)
  272. ;    dc.l    TASKAA            ; (4 bytes)
  273. ;    dc.w    0            ; (2 bytes)
  274. ;TASKAA    dc.b    $84,"TAS",$80+'K'    ; (5+1 bytes)
  275. ;    dc.l    FORTHS            ; link "back" to FORTH (4 bytes)
  276. ;    RTS                ; (2 bytes)
  277.  
  278. ;    To adjust the user dictionary size change the following entry
  279.  
  280.     bss    USRDIC,2048    user dictionary & data stack (might be a little small)
  281.     bss    DSTACK,256
  282.     bss    RSTACK,0    return stack
  283.     bss    TIPBUF,128    terminal input buffer
  284.  
  285. ;    Code Segment
  286.  
  287.     cseg
  288. ;
  289. ; The FORTH program begins here
  290. ;
  291.  
  292.     mlist
  293.     public    _Sforth
  294.  
  295. START
  296.     BRA    COLD    ;;; Cold Start Entry ;;;
  297.     BRA    WARM    ;;; Warm Start Entry ;;;
  298.  
  299. ;
  300. ; Startup parameters
  301. ;
  302.  
  303. ; the following is used to initialize the user area on
  304. ;   cold start only
  305.  
  306. FENCIN    DC.L    TASKAA    initial fence at task
  307. DPINIT    DC.L    USRDIC    cold start value for DP location in dict.
  308. VOCINT    DC.L    FORTH+9    cold start for VOC-LINK
  309. EFUNC    DC.L    $FBEA    address of EFUNC
  310. DELINT    DC.L    0    initial carriage return delay
  311. COLINT    DC.L    80    initial terminal carriage width
  312. ZBLK    DC.L    1    disc block being accessed
  313. ZIN    DC.L    2    scan pointer into the block
  314. ZOUT    DC.L    2    cursor positionx
  315. ZSCR    DC.L    0    disc screen being accessed (0=terminal)
  316. ZOFSET    DC.L    0    disc sector offset for multi-disc
  317. ZCONT    DC.L    TASKAA    last word in primary search vocabulary
  318. ZCURR    DC.L    TASKAA    last word in extensible vocabulary
  319. ZSTATE    DC.L    0    flag for 'interpret' or 'compile' modes
  320. ZBASE    DC.L    10    number base for i/o numeric conversions
  321. ZDPL    DC.L    2    decimal point place
  322. ZFLD    DC.L    0
  323. ZCSP    DC.L    0    current stack position, for compile checks
  324. ZRNUM    DC.L    0
  325. ZHLD    DC.L    0
  326.  
  327. ; end of cold start initialization area
  328.  
  329. ; the following is used to initialize the user area on
  330. ;   warm or cold start
  331.  
  332. SINIT    DC.L    DSTACK    initial top of data stack
  333. TIBINT    DC.L    TIPBUF    terminal input buffer
  334. RINIT    DC.L    RSTACK    initial top of return stack
  335. FINA    DC.L    0    initialize no input file FCB
  336. FOUTA    DC.L    0    initialize no output file FCB
  337. WIDINT    DC.L    31    init name field width
  338. MSGBAS    DC.L    20    init base SCReen number for messages and GO
  339. WRNINT    DC.L    0    init warning mode (0=no disc)
  340. ZQUIET    DC.L    0    echo flag during downloads
  341. ZIRQV    DC.L    0    redirectable IRQ vector
  342. ZFIRQV    DC.L    0    redirectable FIRQ vector
  343. ZNMIV    DC.L    WARM    redirectable NMI vector
  344. ZSWIV    DC.L    0    redirectable SWI vector
  345. ZSWI2V    DC.L    0    redirectable SWI2 vector
  346. ZSWI3V    DC.L    0    redirectable SWI3 vector
  347. ZUVPTR    DC.L    XHLD+4    User variable pointer
  348. ZBOOTV    DC.L    0     User boot word's CFA
  349. ZEMIT    DC.L    EMITX    Redirectable EMIT
  350. ZKEY    DC.L    KEYX    Redirectable KEY
  351. ZQTERM    DC.L    QTERMX    Redirectable ?TERMINAL
  352. UEND
  353.  
  354. ; end warm + cold initialization area
  355.  
  356. _Sforth
  357.     move.l    a7,RETURN    save for BYE
  358.     bra.s    COLD
  359.  
  360.     WORDMX 4,COL,D
  361.  
  362. COLD    movea.l    RINIT,a7    lets get this straight right up front
  363.  
  364. ; move cold and warm start constants into ram
  365.  
  366.     movea.l    #FENCIN,a0
  367.     movea.l    #XFENCE,a1
  368.  
  369. COLD40    move.b    (a0)+,(a1)+
  370.     cmpi.l    #UEND,a0
  371.     bne.s    COLD40
  372.  
  373. ; move 'FORTH' and 'TASK' to ram
  374.  
  375.     movea.l    #RAM,a0
  376.     movea.l    #FORTHS,a1
  377.  
  378. COLD50    move.b    (a0)+,(a1)+
  379.     cmpi.l    #ERAM,a0
  380.     bne.s    COLD50
  381.  
  382. ;    fill in link field pointers.
  383.  
  384.     move.l    #START,a0
  385.     move.l    #0,a1        ; last link field points to null
  386.  
  387. COLD60    cmpa.l    #NOOP,a0    ; at end of dictionary?
  388.     bhi.s    COLD90
  389.     
  390.     cmpi.w    #$ad55,(a0)+    ; found 1st half?
  391.     bne.s    COLD60        ; no
  392.                 ; maybe
  393.     cmpi.w    #$ad55,(a0)+    ; found second half?
  394.     bne.s    COLD60        ; no
  395.  
  396.     subq.l    #4,a0        ; a0 points to link field
  397.     move.l    a1,(a0)        ; point to previous word's NFA
  398.     move.l    a0,a1
  399.  
  400. COLD70    tst.b    -(a1)        ; back up to end of nfa
  401.     bpl.s    COLD70        ; only if name ended on even byte
  402.  
  403. COLD80    tst.b    -(a1)        ; back up to start of nfa
  404.     bpl.s    COLD80
  405.     
  406.     bra.s    COLD60        ; a1 is now pointing to this words nfa
  407.  
  408. ; misc.
  409.  
  410. COLD90    movea.l    XSPZER,a6    initial parameter stack
  411.     movea.l    #START,a4    base address of FORTH
  412.     JSR    UCOLD        user cold start
  413.     JSR    UWARM        user warm start
  414.     DOX    ABORT        go to ABORT if no user auto-start
  415.  
  416.     WORDMX 4,WAR,M
  417. WARM    movea.l    XRZERO,a7    initial return stack
  418.  
  419. ;    Initialize warmstart variables
  420.  
  421.     movea.l    #SINIT,a0
  422.     movea.l    #XSPZER,a1
  423.     
  424. WARM10    move.l    (a0)+,(a1)+
  425.     cmpi.l    #UEND,a0
  426.     bne.s    WARM10
  427.  
  428.     movea.l    XSPZER,a6    initial parameter stack
  429.     movea.l    #START,a4    base address of FORTH
  430.     DO1    UWARM        do user warm start
  431.     DOX    ABORT
  432.  
  433.     WORDMI1    1,,:
  434. COLON    DO6    QEXEC,SCSP,CURENT,AT,CONTXT,STORE
  435.     DO2    CREATE,LIT
  436.     DC.L    -6        ; create advances HERE 6 too far
  437.     DO2    ALLOT,RBRAK
  438.     rts
  439.  
  440.     WORDMI1 1,,;
  441. SEMI    DO2    QCSP,WLITER
  442.     DC.W    $4E75        rts
  443.     DO1    WCOMM
  444.     DOX    LBRAK
  445.  
  446.     WORDMX    2,;,S
  447. SEMIS    addq.l    #4,a7
  448.     rts
  449.  
  450.     WORDMX 7,EXECUT,E
  451. EXEC    movea.l    (a6)+,a0
  452.     jmp    (a0)
  453.  
  454.     WORDMX 3,MO,N
  455. MON    jmp    PMON
  456.  
  457.     WORDMX 3,BY,E
  458. BYE    movea.l    RETURN,a7
  459.     rts
  460.  
  461.     WORDMX 3,JS,R
  462. JSR    movea.l    (a6)+,a0
  463.     jmp    (a0)
  464.  
  465.     WORDMX 4,EMI,T
  466. EMIT    movea.l    XEMIT,a0
  467.     jmp    (a0)        ; to current EMIT handler
  468.  
  469. EMITX    move.l    (a6)+,d0
  470.     jsr    PEMIT
  471.     addq.l    #1,XOUT
  472.     rts
  473.  
  474.     WORDMX 3,KE,Y
  475. KEY    movea.l    XKEY,a0
  476.     jmp    (a0)        ; to current KEY handler
  477.  
  478. KEYX    jsr    PKEY
  479.     move.l    d0,-(a6)
  480.     rts
  481.  
  482.     WORDMX 9,?TERMINA,L
  483. QTERM    movea.l    XQTERM,a0
  484.     jmp    (a0)        ; to current ?TERMINAL handler
  485.  
  486. QTERMX    jsr    PQTER
  487.     move.l    d0,-(a6)
  488.     rts
  489.  
  490.     WORDMX 2,C,R
  491. CR    DO2    QTERM,ZBRAN
  492.     dc.w    CR1-START
  493.  
  494.     DO1    QUIT
  495.  
  496. CR1    DO1    WLITER
  497.     dc.w    $0A
  498.  
  499.     DO2    EMIT,WLITER
  500.     dc.w    $0D line feed
  501.  
  502.     DO5    EMIT,ZERO,OUT,STORE,LIT
  503.     dc.l    XDELAY
  504.  
  505.     DO2    AT,ZBRAN
  506.     dc.w    CRE-START
  507.  
  508.     DO1    LIT
  509.     dc.l    XDELAY
  510.  
  511.     DO3    AT,ZERO,XDO
  512. CR2    DO3    ZERO,EMIT,XLOOP
  513.     dc.w    CR2-START
  514.  
  515. CRE    rts
  516.  
  517.     WORDMX 3,SP,@
  518. SPAT    movea.l    a6,a0        ; get current value of parameter stack pointer
  519.     move.l a0,-(a6)
  520.     rts
  521.  
  522.     WORDMX 3,SP,!
  523. SPSTOR    movea.l    XSPZER,a6
  524.     rts
  525.  
  526.     WORDMX 3,RP,!
  527. RPSTOR    movea.l    (a7),a0        ; save return address in a0
  528.     movea.l XRZERO,a7    ; initialize return stack ptr from constant
  529.     jmp    (a0)        ; return like an rts
  530.  
  531.     WORDMX 3,LI,T
  532. LIT    movea.l    (a7)+,a0    ; return address points to literal
  533.     move.l    (a0)+,-(a6)
  534.     jmp    (a0)
  535.  
  536. WLITER    movea.l    (a7)+,a0    ; return address points to literal
  537.     move.w    (a0)+,d0
  538.     ext.l    d0
  539.     move.l    d0,-(a6)
  540.     jmp    (a0)
  541.  
  542. ;
  543. ;    These are the branches used within the kernel. They use
  544. ;    a4 relative addressing. a4 points to the base of the kernel
  545. ;
  546.  
  547. BRAN    bra.s    ZBYES        ; go steal code in ZBRANCH
  548.  
  549. ZBRAN    move.l    (a6)+,d0    ; get quantity on stack and drop it
  550.     bne.s    ZBNO
  551.  
  552. ZBYES    movea.l    (a7)+,a0    ; return addr pts to a4 relative offset
  553.     movea.w    (a0),a1        ; get offset into a1
  554.     jmp    0(a4,a1.w)    ; take branch
  555.  
  556. ZBNO    movea.l    (a7)+,a0    ; return addr pts to offset
  557.     jmp    2(a0)        ; jmp over it
  558. ;
  559. ;    These are the (LOOP) and (+LOOP) used within the kernel. They use
  560. ;    a4 relative addressing. a4 points to the base of the kernel
  561. ;
  562.  
  563. XLOOP    moveq.l    #1,d0        ; set inc cntr to 1
  564.     bra.s    XPLOP2        ; and steal other code
  565.  
  566. XPLOOP    move.l    (a6)+,d0    ; remove step from stack
  567.  
  568. XPLOP2    bpl.s    XPLOF        ; forward loopint
  569.     add.l    4(a7),d0    ; add step to index
  570.     move.l    d0,4(a7)
  571.     cmp.l    8(a7),d0    ; compare with limit
  572.     bpl.s    ZBYES        ; if not there yet (index >= loop)
  573.     bra.s    XPLONO        ; fall thru if index < loop
  574.  
  575. XPLOF    add.l    4(a7),d0    ; add step to index
  576.     move.l    d0,4(a7)
  577.     cmp.l    8(a7),d0    ; compare with limit
  578.     bmi.s    ZBYES        ; if not there yet (index < loop)
  579.                 ; fall thru if index >= loop
  580.  
  581. XPLONO    movea.l    (a7)+,a0    ; return address pts to loop branch
  582.     addq.l    #8,a7        ; drop index & limit from return stack
  583.     jmp    2(a0)
  584.  
  585. ;
  586. ;    These are the branches used outside the kernel. The return address
  587. ;    points to the offset which is one word in length.
  588. ;
  589.  
  590.     WORDMX 6,BRANC,H
  591. BRANCH    bra.s    ZBYE10
  592.  
  593.     WORDMX 7,0BRANC,H
  594. ZBRANCH    move.l    (a6)+,d0    ; get quantity on stack and drop it
  595.     bne.s    ZBNO10
  596.  
  597. ZBYE10    movea.l    (a7)+,a0    ; return addr pts to offset
  598.     movea.w    (a0),a1        ; get offset into a1
  599.     jmp    0(a0,a1.w)    ; take branch
  600.  
  601. ZBNO10    movea.l    (a7)+,a0    ; return addr pts to offset
  602.     jmp    2(a0)        ; jmp over it
  603.  
  604. ;
  605. ;    These are the (LOOP) and (+LOOP) used outside the kernel.
  606. ;
  607.  
  608.     WORDMX 6,(LOOP,)
  609. FLOOP    moveq.l    #1,d0        ; set inc cntr to 1
  610.     bra.s    FPLOP2        ; and steal other code
  611.  
  612.     WORDMX 7,(+LOOP,)
  613. FPLOOP    move.l    (a6)+,d0    ; remove step from stack
  614.  
  615. FPLOP2    bpl.s    FPLOF        ; forward loopint
  616.     add.l    4(a7),d0    ; add step to index
  617.     move.l    d0,4(a7)
  618.     cmp.l    8(a7),d0    ; compare with limit
  619.     bpl.s    ZBYE10        ; if not there yet (index >= loop)
  620.     bra.s    FPLONO        ; fall thru if index < loop
  621.  
  622. FPLOF    add.l    4(a7),d0    ; add step to index
  623.     move.l    d0,4(a7)
  624.     cmp.l    8(a7),d0    ; compare with limit
  625.     bmi.s    ZBYE10        ; if not there yet (index < loop)
  626.                 ; fall thru if index >= loop
  627.  
  628. FPLONO    movea.l    (a7)+,a0    ; return address pts to loop branch
  629.     addq.l    #8,a7        ; drop index & limit from return stack
  630.     jmp    2(a0)
  631.  
  632.     WORDMX 4,(DO,)
  633. XDO    move.l    (a6)+,d0    ; counter
  634.     move.l    (a6)+,d1    ; limit
  635.     movea.l    (a7)+,a0    ; pick up return address
  636.     move.l    d1,-(a7)    ; move limit to return stack
  637.     move.l    d0,-(a7)    ; move index to return stack
  638.     jmp    (a0)        ; carry on
  639.  
  640.     wordm1 1,,I
  641. I    move.l    4(a7),-(a6)    ; move index to parameter stack
  642.     rts
  643.  
  644.     WORDM1 1,,J
  645. J    move.l    8(a7),-(a6)    ; move limit to parameter stack
  646.     rts
  647.  
  648.     WORDM1 1,,K
  649. K    move.l    12(a7),-(a6)    ; get third counter
  650.     rts
  651.  
  652.     WORDMX 5,DIGI,T
  653. DIGIT
  654.     move.l    4(a6),d0    ; second item is char of interest
  655.     subi.l    #$30,d0        ; ASCII zero
  656.     bmi.s    DIGIT2        ; if less than '0', ILLEGAL
  657.     cmpi.l    #$0A,d0
  658.     bmi.s    DIGIT0        ; if '9' or less
  659.     cmpi.l    #$11,d0
  660.     bmi.s    DIGIT2        ; if less than 'A'
  661.     andi.b    #%11011111,d0    ; force upper case
  662.     cmpi.l    #$2B,d0
  663.     bpl.s    DIGIT2        ; if greater than 'Z'
  664.     subq.l    #7,d0        ; translate 'A' thru 'Z'
  665.  
  666. DIGIT0    cmp.l    (a6),d0
  667.     bpl.s    DIGIT2        ; if not less than base
  668.     move.l    #1,(a6)        ; true flag
  669.     move.l    d0,4(a6)
  670.     rts
  671.  
  672. DIGIT2    lea.l    4(a6),a6    ; pop top off
  673.     move.l    #0,(a6)        ; bad char flag
  674.     rts
  675.  
  676.     WORDMX 6,(FIND,)
  677. PFIND
  678. PFND05    movea.l    (a6),a0        ; current nfa
  679.     movea.l    4(a6),a1    ; start of text string
  680.  
  681.     clr.l    d0
  682.     clr.l    d1
  683.     move.b    (a0)+,d0    ; get byte count of this words name
  684.     move.l    d0,d1        ; in case this is the one
  685.     and.l    #$1f,d0        ; mask non count bits
  686.  
  687.     cmp.b    (a1)+,d0    ; are the lengths the same?
  688.     bne.s    PFND20        ; if not then go find next nfa
  689.     bra.s    PFND10
  690.  
  691. PFND08    cmp.b    (a0)+,d0
  692.     beq.s    PFND10
  693.     eori.b    #%00100000,d0    ; toggle case of character
  694.     cmp.b    -1(a0),d0    ; and try again
  695.     bne.s    PFND20
  696.  
  697. PFND10    move.b    (a1)+,d0    ; compare next byte
  698.     tst.b    (a0)        ; dictionary entry negative?
  699.     bpl.s    PFND08
  700.     ori.b    #$80,d0        ; make our byte negative too
  701.     cmp.b    (a0),d0        ; is this it?
  702.     beq.s    PFND15        ; yes
  703.     eori.b    #%00100000,d0    ; no, toggle case of character
  704.     cmp.b    (a0),d0        ; and try again
  705.     bne.s    PFND20        ; no, try next one
  706.  
  707. PFND15    move.l    a0,d0
  708.     addq.l    #2,d0        ; align to word boundary
  709.     andi.b    #$FE,d0        ; round up to even address (link field)
  710.     addi.l    #10,d0        ; convert to pfa
  711.  
  712.     move.l    d0,4(a6)    ; copy this pfa to correct place on stack
  713.     move.l    d1,(a6)        ; length of name field
  714.     move.l    #1,-(a6)    ; true
  715.     rts
  716.  
  717. PFND20    btst.b    #7,(a0)+    ; find trailing character
  718.     beq.s    PFND20
  719.     move.l    a0,d0
  720.     addq.l    #1,d0        ; align to word boundary
  721.     andi.b    #$FE,d0        ; round up to even address
  722.     move.l    d0,a0        ; a0 points to link field
  723.     tst.l    (a0)        ; end of dictionary?
  724.     beq.s    PFND30        ; yes
  725.     move.l    (a0),(a6)    ; make this the current nfa
  726.     bra    PFND05        ; and try again
  727.  
  728. PFND30    addq.l    #4,a6        ; drop
  729.     move.l    #0,(a6)        ; false
  730.     rts
  731.  
  732.     WORDMX 7,ENCLOS,E
  733. ENCLOS    move.l    (a6)+,d0    ; delimiter
  734.     movea.l    (a6),a0        ; start addr of string
  735.     clr.l    d1
  736.  
  737. ENCL05    tst.b    (a0)        ; is char a null?
  738.     beq.s    ENCL25        ; yes, then it is the delimiter
  739.     cmp.b    (a0),d0        ; at non delimiter?
  740.     bne.s    ENCL10
  741.     addq.l    #1,a0        ; incr pointer
  742.     addq.l    #1,d1        ; incr byte offset counter
  743.     bra.s    ENCL05
  744.  
  745. ENCL10    move.l    d1,-(a6)    ; push offset to first non delimiter
  746.  
  747. ENCL15    tst.b    (a0)        ; next character a null?
  748.     beq.s    ENCL30        ; yes
  749.     cmp.b    (a0)+,d0    ; is it the delimiter yet?
  750.     beq.s    ENCL20
  751.     addq.l    #1,d1        ; incr byte offset counter
  752.     bra.s    ENCL15
  753.  
  754. ENCL20    move.l    d1,-(a6)    ; push offset to delimiter after word
  755.     addq.l    #1,d1
  756.     move.l    d1,-(a6)    ; push offset to 1st char not scanned
  757.     rts
  758.  
  759. ENCL25    move.l    d1,-(a6)
  760.     addq.l    #1,d1
  761.     move.l    d1,-(a6)
  762.     subq.l    #1,d1
  763.     move.l    d1,-(a6)
  764.     rts
  765.  
  766. ENCL30    move.l    d1,-(a6)    ; byte offset of null
  767.     move.l    d1,-(a6)    ; byte offset of null
  768.     rts
  769.  
  770.     WORDMX 5,CMOV,E
  771. CMOVE    move.l    (a6)+,d0
  772.     movea.l    (a6)+,a1
  773.     movea.l    (a6)+,a0
  774.     subq.l    #1,d0        ; for dbra
  775.  
  776. CMOVE1    move.b    (a0)+,(a1)+
  777.     dbra    d0,CMOVE1
  778.     rts
  779.     
  780.     WORDMX 5,WMOV,E
  781. WMOVE    move.l    (a6)+,d0
  782.     movea.l    (a6)+,a1
  783.     movea.l    (a6)+,a0
  784.     subq.l    #1,d0        ; for dbra
  785.  
  786. WMOVE1    move.w    (a0)+,(a1)+
  787.     dbra    d0,WMOVE1
  788.     rts
  789.  
  790.     WORDMX 4,MOV,E
  791. MOVE    move.l    (a6)+,d0
  792.     movea.l    (a6)+,a1
  793.     movea.l    (a6)+,a0
  794.     subq.l    #1,d0        ; for dbra
  795.  
  796. MOVE1    move.l    (a0)+,(a1)+
  797.     dbra    d0,MOVE1
  798.     rts
  799.  
  800.     WORDMX 2,U,*
  801. USTAR    move.l    (a6),d0        ; a0 in lo word of d0
  802.     move.l    4(a6),d1
  803.  
  804.     move.l    d1,d2
  805.     move.l    d1,d3
  806.     move.l    d1,d4
  807.     swap    d2        ; b1 in lo half of d2
  808.     swap    d4        ; b1 in lo half of d4
  809.     mulu    d0,d1        ; a0*b0 = d1
  810.     mulu    d0,d2        ; a0*b1 = d2
  811.     swap    d0        ; move a1 to lo word of d0
  812.     mulu    d0,d3        ; a1*b0 = d3
  813.     mulu    d0,d4        ; a1*b1 = d4
  814.     move.l    #0,(a6)        ; 0 to msp
  815.     move.l    d1,4(a6)    ; a0*b0
  816.     add.l    d2,2(a6)    ; + a0*b1*2^16
  817.     add.l    d3,2(a6)    ; + a1*b0*2^16
  818.     move.l    (a6),d5
  819.     addx.l    d5,d4        ; + a1*b1*2^32
  820.     move.l    d4,(a6)
  821.     rts
  822.  
  823.     WORDMX 2,U,/
  824. USLASH    DO2    USLASHM,SWAP
  825.     addq.l #4,a6        ; drop
  826.     RTS
  827.  
  828.     WORDMX 5,U/MO,D
  829. USLASHM    move.l    (a6)+,d1
  830.     move.l    (a6)+,d0
  831.     jsr    comdivide
  832.     move.l    d1,-(a6)    ; push remainder
  833.     move.l    d0,-(a6)    ; push quotient
  834.     rts
  835.  
  836. comdivide:
  837.     movem.l    d2/d3,-(sp)
  838.     swap    d1        ;check high word
  839.     tst.w    d1        ;check for easy case
  840.     bne.s    hardldv
  841.     swap    d1        ;get low word back
  842.     clr.w    d3
  843.     divu    d1,d0
  844.     bvc.s    format
  845.     move.w    d0,d2
  846.     clr.w    d0
  847.     swap    d0
  848.     divu    d1,d0
  849.     move.w    d0,d3
  850.     move.w    d2,d0
  851.     divu    d1,d0
  852. format:
  853.     move.l    d0,d1
  854.     swap    d0
  855.     move.w    d3,d0
  856.     swap    d0
  857.     clr.w    d1
  858.     swap    d1
  859.     movem.l    (sp)+,d2/d3
  860.     rts
  861. hardldv:
  862.     swap    d1
  863.     clr.l    d2        ;clear out top half of dividend
  864.     move.l    #31,d3        ;set up loop count
  865. hardloop:
  866.     asl.l    #1,d0
  867.     roxl.l    #1,d2
  868.     sub.l    d1,d2        ;subtract divisor till negative
  869.     bmi.s    zerobit
  870. onebit:
  871.     add.l    #1,d0        ;set bit in quotient
  872.     dbra    d3,hardloop
  873.     bra.s    hard_done
  874. zeroloop:
  875.     asl.l    #1,d0
  876.     roxl.l    #1,d2        ;shift dividend left one bit
  877.     add.l    d1,d2        ;add divisor till positive
  878.     bpl.s    onebit
  879. zerobit:
  880.     dbra    d3,zeroloop
  881.     add.l    d1,d2        ;add divisor in one more time to fix remainder
  882. hard_done:
  883.     move.l    d2,d1        ;copy remainder
  884.     movem.l    (sp)+,d2/d3
  885.     rts
  886.  
  887.     WORDMMX 3,AN,D
  888. AND     move.l    (a6)+,d0
  889.     and.l    d0,(a6)
  890.     rts
  891.  
  892.     WORDMMX 2,O,R
  893. OR     move.l    (a6)+,d0
  894.     or.l    d0,(a6)
  895.     rts
  896.     
  897.     WORDMMX 3,XO,R
  898. XOR     move.l    (a6)+,d0
  899.     eor.l    d0,(a6)
  900.     rts
  901.     
  902.     WORDMM1 1,,+
  903. PLUS     move.l    (a6)+,d0
  904.     add.l    d0,(a6)
  905.     rts
  906.  
  907.     WORDM1 1,,-
  908. SUB    DO1    MINUS
  909.     DOX    PLUS
  910.  
  911.     WORDMX 2,D,+
  912. DPLUS    move.l    (a6)+,d0    ; high part
  913.     move.l    (a6)+,d1    ; low part
  914.     add.l    4(a6),d1    ; add low parts
  915.     move.l    (a6),d2
  916.     addx.l    d2,d0        ; add high parts
  917.     move.l    d0,(a6)
  918.     move.l    d1,4(a6)
  919.     rts
  920.  
  921.     WORDMMX 5,MINU,S
  922. MINUS     neg.l    (a6)
  923.     rts
  924.  
  925.     WORDMMX 6,DMINU,S
  926. DMINUS     neg.l    (a6)
  927.      negx.l    4(a6)
  928.     rts
  929.  
  930.     WORDMMX 2,1,+
  931. ONEP    addq.l    #1,(a6)
  932.     rts
  933.  
  934.     WORDMMX 2,2,+
  935. TWOP    addq.l    #2,(a6)
  936.     rts
  937.  
  938.     WORDMMX 2,4,+
  939. FOURP    addq.l    #4,(a6)
  940.     rts
  941.  
  942.     WORDMMX 2,1,-
  943. ONEM    subq.l    #1,(a6)
  944.     rts
  945.  
  946.     WORDMMX 2,2,-
  947. TWOM     subq.l    #2,(a6)
  948.     rts
  949.  
  950.     WORDMMX 2,4,-
  951. FOURM     subq.l    #4,(a6)
  952.     rts
  953.  
  954.     WORDMMX 2,2,*
  955. TWOSTAR    move.l    (a6),d0
  956.     lsl.l    #1,d0
  957.     move.l    d0,(a6)
  958.     rts
  959.  
  960.     WORDMMX 2,4,*
  961. FOURSTAR move.l    (a6),d0
  962.     lsl.l    #2,d0
  963.     move.l    d0,(a6)
  964.     rts
  965.  
  966.     WORDMMX 2,2,/
  967. TWODIV    move.l    (a6),d0
  968.     asr.l    #1,d0
  969.     move.l    d0,(a6)
  970.     rts
  971.  
  972.     WORDMMX 2,4,/
  973. FOURDIV move.l    (a6),d0
  974.     asr.l    #2,d0
  975.     move.l    d0,(a6)
  976.     rts
  977.  
  978. ; quick multiply of two 16 bit numbers
  979.  
  980.     WORDMX 2,Q,*
  981. QSTAR    move.l    (a6)+,d0    ; w/ 32 bit result
  982.     move.l    (a6)+,d1
  983.     muls    d0,d1
  984.     move.l    d1,-(a6)
  985.     rts
  986.  
  987. ; multiply two 32 bit numbers
  988.  
  989.     WORDM1 1,,*
  990. STAR    DO1    USTAR        ; w/ 32 bit result
  991.     addq.l #4,a6        ; drop
  992.     rts
  993.  
  994.     WORDMX 4,/MO,D
  995. SLMOD    move.l    (a6)+,d1
  996.     move.l    (a6)+,d0
  997.     move.l    d4,-(sp)
  998.     clr.l    d4            ;mark result as positive
  999.     tst.l    d0
  1000.     bpl.s    prim_ok
  1001.     neg.l    d0
  1002.     add.w    #1,d4            ;mark as negative
  1003. prim_ok:
  1004.     tst.l    d1
  1005.     bpl.s    sec_ok
  1006.     neg.l    d1
  1007.     eor.w    #1,d4            ;flip sign of result
  1008. sec_ok:
  1009.     jsr    comdivide
  1010. chksign:
  1011.     tst.w    d4
  1012.     beq.s    posres
  1013.     neg.l    d0            ; change sign of quotient
  1014.     neg.l    d1            ; change sign of remainder
  1015. posres:
  1016.     move.l    (sp)+,d4
  1017.     move.l    d1,-(a6)        ; push remainder
  1018.     move.l    d0,-(a6)        ; push quotient
  1019.     rts
  1020.  
  1021.     WORDM1 1,,/
  1022. SLASH    DO2    SLMOD,SWAP
  1023.     addq.l #4,a6            ; drop remainder
  1024.     rts
  1025.  
  1026.     WORDMX 3,MO,D
  1027. MOD    DO1    SLMOD
  1028.     addq.l #4,a6            ; drop quotient
  1029.     rts
  1030.  
  1031.     WORDMX 2,*,/
  1032. SSLASH    DO3    TOR,STAR,FROMR
  1033.     DOX    SLASH
  1034.  
  1035.     WORDMX 5,M/MO,D
  1036. MSMOD    DO7    TOR,ZERO,R,USLASH,FROMR,SWAP,TOR
  1037.     DO2    USLASH,FROMR
  1038.     rts
  1039.  
  1040.     WORDMX 3,AB,S
  1041. ABS    DO3    DUP,ZLESS,ZBRAN
  1042.     dc.w    ABS2-START
  1043.     DOX    MINUS
  1044. ABS2    rts
  1045.  
  1046.     WORDMX 4,DAB,S
  1047. DABS    DO3    DUP,ZLESS,ZBRAN
  1048.     dc.w     DABS2-START
  1049.     DOX    DMINUS
  1050. DABS2    rts
  1051.  
  1052.     WORDM1 1,,<
  1053. LESS    move.l    4(a6),d0    ; get A
  1054.     cmp.l    (a6)+,d0    ; A - B
  1055.     blt.s    LESS1
  1056.     move.l    #0,(a6)        ; not less than
  1057.     rts
  1058. LESS1    move.l    #1,(a6)
  1059.     rts
  1060.  
  1061.     WORDM1 1,,=
  1062. EQUAL    DO1    SUB
  1063.     DOX    ZEQU
  1064.  
  1065.     WORDM1 1,,>
  1066. GREAT    DO1    SWAP
  1067.     DOX    LESS
  1068.  
  1069.     WORDMX 2,+,-
  1070. SETSN    DO2    ZLESS,ZBRAN
  1071.     dc.w    SETSN2-START
  1072.     DOX    MINUS
  1073. SETSN2    rts
  1074.  
  1075.     WORDMX 3,D+,-
  1076. DSETSN    DO2    ZLESS,ZBRAN
  1077.     dc.w    DSETS2-START
  1078.     DOX    DMINUS
  1079. DSETS2    rts
  1080.  
  1081.     WORDMX 2,0,=
  1082. ZEQU    tst.l    (a6)
  1083.     beq.s    ZEQU10
  1084.     move.l    #0,(a6)
  1085.     rts
  1086.  
  1087. ZEQU10    move.l    #1,(a6)
  1088.     rts
  1089.  
  1090.     WORDMX 3,NO,T
  1091. NOT    bra.s    ZEQU
  1092.  
  1093.     WORDMX 2,0,<
  1094. ZLESS    tst.l    (a6)
  1095.     bmi.s    ZLESS10
  1096.     move.l    #0,(a6)
  1097.     rts
  1098.  
  1099. ZLESS10    move.l    #1,(a6)
  1100.     rts
  1101.  
  1102.     WORDMMX 5,LEAV,E
  1103. LEAVE    move.l    4(a7),8(a7)
  1104.     rts
  1105.  
  1106.     WORDMMX 2,>,R
  1107. TOR    movea.l    (a7),a0
  1108.     move.l    (a6)+,(a7)
  1109.     jmp    (a0)
  1110.     rts
  1111.  
  1112.     WORDMMX 2,R,>
  1113. FROMR    movea.l    (a7)+,a0
  1114.     move.l    (a7)+,-(a6)
  1115.     jmp    (a0)
  1116.     rts
  1117.  
  1118.     WORDMM1 1,,R
  1119. R    move.l    4(a7),-(a6)
  1120.     rts
  1121.  
  1122.     WORDMMX 4,OVE,R
  1123. OVER    move.l    4(a6),d0
  1124.     move.l    d0,-(a6)
  1125.     rts
  1126.  
  1127.     WORDMMX 4,DRO,P
  1128. DROP    addq.l    #4,a6
  1129.     rts
  1130.  
  1131.     WORDMMX 4,SWA,P
  1132. SWAP    move.l    (a6),d0
  1133.     move.l    4(a6),(a6)
  1134.     move.l    d0,4(a6)
  1135.     rts
  1136.  
  1137.     WORDMMX 3,DU,P
  1138. DUP    move.l    (a6),-(a6)
  1139.     rts
  1140.  
  1141.     WORDMX 3,RO,T
  1142. ROT    DO3    TOR,SWAP,FROMR
  1143.     DOX    SWAP
  1144.  
  1145.     WORDMX 4,PIC,K
  1146. PICK    move.l    (a6),d0
  1147.     mulu.w    #4,d0
  1148.     move.l    0(a6,d0.l),(a6)
  1149.     rts
  1150.  
  1151.     WORDMMX 2,+,!
  1152. PSTORE    movea.l    (a6)+,a0
  1153.     move.l    (a6)+,d0
  1154.     add.l    d0,(a0)
  1155.     rts
  1156.  
  1157.     WORDMM1 1,,@
  1158. AT     movea.l    (a6),a0
  1159.     move.l    (a0),(a6)
  1160.     rts
  1161.  
  1162.     WORDMX 2,W,@
  1163. WAT     movea.l    (a6),a0
  1164.     clr.l    d0
  1165.     move.w    (a0),d0
  1166.     move.l    d0,(a6)
  1167.     rts
  1168.  
  1169.     WORDMX 2,C,@
  1170. CAT     movea.l    (a6),a0
  1171.     clr.l    d0
  1172.     move.b    (a0),d0
  1173.     move.l    d0,(a6)
  1174.     rts
  1175.  
  1176.     WORDMM1 1,,!
  1177. STORE    movea.l    (a6)+,a0
  1178.     move.l    (a6)+,(a0)
  1179.     rts
  1180.  
  1181.     WORDMMX 2,W,!
  1182. WSTORE    movea.l    (a6)+,a0
  1183.     move.l    (a6)+,d0
  1184.     move.w    d0,(a0)
  1185.     rts
  1186.  
  1187.     WORDMMX 2,C,!
  1188. CSTORE    movea.l    (a6)+,a0
  1189.     move.l    (a6)+,d0
  1190.     move.b    d0,(a0)
  1191.     rts
  1192.  
  1193. ;
  1194. ; CREATES: DICTIONARY HEADER
  1195. ;          jsr CON
  1196. ;          dc.l    0
  1197. ;
  1198.  
  1199.     WORDMX 7,<BUILD,S
  1200. BUILDS    DO1    ZERO
  1201.     DOX    CON
  1202.  
  1203. ;
  1204. ; CREATES: DICT HEADER
  1205. ;          jsr DODOES
  1206. ;          dc.l ADDRESS1
  1207. ; ADDRESS2 equ *
  1208. ;
  1209. ; WHEN EXECUTED, WILL PLACE ADDRESS2 ON STACK
  1210. ; THEN EXECUTES CODE AT ADDRESS1
  1211. ;
  1212.  
  1213.     WORDMX 5,DOES,>
  1214. DOES    move.l    (a7)+,-(a6)    ; move return address (ADDRESS1) to stack
  1215.     DO4    LATEST,PFA,STORE,PSCODE
  1216.  
  1217. DODOES    movea.l    (a7)+,a0    ; don't return there
  1218.     lea.l    4(a0),a1    ; point to address2
  1219.     move.l    a1,-(a6)    ; place on stack
  1220.     movea.l    (a0),a0        ; get address of handler
  1221.     jmp    (a0)        ; jump to address1
  1222.  
  1223.     WORDMX 6,TOGGL,E
  1224. TOGGLE    DO4    OVER,CAT,XOR,SWAP
  1225.     DOX    CSTORE
  1226.  
  1227.     WORDMX 8,CONSTAN,T
  1228. CON    DO3    CREATE,COMMA,PSCODE
  1229. DOCON    movea.l    (a7)+,a0
  1230.     move.l    (a0),-(a6)
  1231.     rts
  1232.  
  1233.     WORDMX    5,TOVA,R
  1234. TOVAR    bra.s    CON
  1235.  
  1236.     WORDMIX    2,T,O
  1237. TO    DO4    TICK,STATE,AT,ZBRAN
  1238.     dc.w    TO10-START
  1239.     DO2    COMPIL,STORE
  1240.     RTS
  1241.  
  1242. TO10    DOX    STORE
  1243.  
  1244.     WORDMX 8,VARIABL,E
  1245. VAR    DO2    CON,PSCODE
  1246. DOVAR    move.l    (a7)+,-(a6)
  1247.     rts
  1248.  
  1249.     WORDMM1 1,,0
  1250. ZERO    moveq.l    #0,d0
  1251.     move.l    d0,-(a6)
  1252.     rts
  1253.  
  1254.     WORDMM1 1,,1
  1255. ONE    moveq.l    #1,d0
  1256.     move.l    d0,-(a6)
  1257.     rts
  1258.  
  1259.     WORDMM1 1,,2
  1260. TWO    moveq.l    #2,d0
  1261.     move.l    d0,-(a6)
  1262.     rts
  1263.  
  1264.     WORDMM1 1,,3
  1265. THREE    moveq.l    #3,d0
  1266.     move.l    d0,-(a6)
  1267.     rts
  1268.  
  1269.     WORDMM1 1,,4
  1270. FOUR    moveq.l    #4,d0
  1271.     move.l    d0,-(a6)
  1272.     rts
  1273.  
  1274.     WORDMMX 2,B,L
  1275. BL    moveq.l    #$20,d0
  1276.     move.l    d0,-(a6)    ; ascii blank
  1277.     rts
  1278.  
  1279.     WORDMMX 3,C/,L
  1280. CSL    moveq.l    #80,d0
  1281.     move.l    d0,-(a6)
  1282.     rts
  1283.  
  1284.     WORDMMX    5,STAR,T
  1285. STRT    move.l    #START,-(a6)
  1286.     rts
  1287.  
  1288.     WORDMX 4,USE,R
  1289. USER    DO2    CON,PSCODE
  1290. DOUSER    movea.l    (a7)+,a0    ; gets offset to user's table
  1291.     move.l    (a0),d0
  1292.     add.l    #UBEGIN,d0    ; add to users base address
  1293.     move.l    d0,-(a6)
  1294.     rts
  1295.  
  1296.     WORDMX 7,+ORIGI,N
  1297. PORIG    DO1    LIT
  1298.     dc.l    START
  1299.     DOX    PLUS
  1300.  
  1301.     WORDMX 2,S,0
  1302. SZERO    DO1    DOUSER
  1303.     dc.l    XSPZER-UBEGIN
  1304.  
  1305.     WORDMX 2,R,0
  1306. RZERO    DO1    DOUSER
  1307.     dc.l    XRZERO-UBEGIN
  1308.  
  1309.     WORDMU  3,TI,B,TIB,XTIB
  1310.     WORDMU  5,WIDT,H,WIDTH,XWIDTH
  1311.     WORDMU  7,WARNIN,G,WARN,XWARN
  1312.     WORDMU  5,FENC,E,FENCE,XFENCE
  1313.     WORDMU  2,D,P,DPTR,XDP
  1314.     WORDMU  8,VOC-LIN,K,VOCLIN,XVOCL
  1315.     WORDMU  3,BL,K,BLK,XBLK
  1316.     WORDMU  2,I,N,IN,XIN
  1317.     WORDMU  3,OU,T,OUT,XOUT
  1318.     WORDMU  3,SC,R,SCR,XSCR
  1319.     WORDMU  6,OFFSE,T,OFSET,XOFSET
  1320.     WORDMU  7,CONTEX,T,CONTXT,XCONT
  1321.     WORDMU  7,CURREN,T,CURENT,XCURR
  1322.     WORDMU  5,STAT,E,STATE,XSTATE
  1323.     WORDMU  4,BAS,E,BASE,XBASE
  1324.     WORDMU  3,DP,L,DPL,XDPL
  1325.     WORDMU  3,FL,D,FLD,XFLD
  1326.     WORDMU  3,CS,P,CSP,XCSP
  1327.     WORDMU  2,R,#,RNUM,XRNUM
  1328.     WORDMU  3,HL,D,HLD,XHLD
  1329.     WORDMU  7,COLUMN,S,COLUMS,XCOLUM
  1330.     WORDMU  4,IRQ,V,IRQV,XIRQV
  1331.     WORDMU  5,FIRQ,V,FIRQV,XFIRQV
  1332.     WORDMU  4,NMI,V,NMIV,XNMIV
  1333.     WORDMU  4,SWI,V,SWIV,XSWIV
  1334.     WORDMU  5,SWI2,V,SWI2V,XSWI2V
  1335.     WORDMU  5,SWI3,V,SWI3V,XSWI3V
  1336.     WORDMU  5,EMIT,V,EMITV,XEMIT
  1337.     WORDMU  4,KEY,V,KEYV,XKEY
  1338.     WORDMU  10,?TERMINAL,V,QTERMV,XQTERM
  1339.     WORDMU  5,QUIE,T,QUIET,XQUIET
  1340.     WORDMU  5,UVPT,R,UVPTR,XUVPTR
  1341.     WORDMU  5,BOOT,V,BOOTV,XBOOTV
  1342.     WORDMU  4,BYE,V,BYEV,RETURN
  1343.  
  1344. ;
  1345.     WORDMX 4,HER,E
  1346. HERE    DO1    DPTR
  1347.     DOX    AT
  1348.  
  1349.     WORDMX 5,ALLO,T
  1350. ALLOT    DO1    DPTR
  1351.     DOX PSTORE
  1352.  
  1353.     WORDMX    7,WALLIG,N
  1354. WALLIGN    DO2    ONEP,LIT
  1355.     dc.l    $FFFFFFFE
  1356.     DOX    AND
  1357.  
  1358. ;    WORDM1 1,,,
  1359.     dc.b    $80+1,$80+','
  1360.     dc.l    $ad55ad55
  1361. COMMA    DO3    HERE,STORE,FOUR
  1362.     DOX    ALLOT
  1363.  
  1364. ;    WORDMX 2,W,,
  1365.     dc.b    $80+2,"W",$80+','
  1366.     dc.l    $ad55ad55
  1367. WCOMM    DO3    HERE,WSTORE,TWO
  1368.     DOX    ALLOT
  1369.  
  1370. ;    WORDMX 2,C,,
  1371.     dc.b    $80+2,"C",$80+','
  1372.     dc.l    $ad55ad55
  1373. CCOMM    DO3    HERE,CSTORE,ONE
  1374.     DOX    ALLOT
  1375.  
  1376.     WORDMX 5,SPAC,E
  1377. SPACE    DO1    BL
  1378.     DOX    EMIT
  1379.  
  1380.     WORDMX 3,MI,N
  1381. MIN    DO4    OVER,OVER,GREAT,ZBRAN
  1382.     dc.w    MIN2-START
  1383.     DO1    SWAP
  1384. MIN2    addq.l #4,a6 drop
  1385.     rts
  1386.  
  1387.     WORDMX 3,MA,X
  1388. MAX    DO4    OVER,OVER,LESS,ZBRAN
  1389.     dc.w    MAX2-START
  1390.     DO1    SWAP
  1391. MAX2    addq.l #4,a6
  1392.     rts
  1393.  
  1394.     WORDMX 4,-DU,P
  1395. DDUP    DO2    DUP,ZBRAN
  1396.     dc.w    DDUP2-START
  1397.     DOX    DUP
  1398. DDUP2    rts
  1399.  
  1400.     WORDMX 8,TRAVERS,E
  1401. TRAV    DO1    SWAP
  1402. TRAV2    DO3    OVER,PLUS,WLITER
  1403.     dc.w    $7F
  1404.     DO4    OVER,CAT,LESS,ZBRAN
  1405.     dc.w    TRAV2-START
  1406.     DO2    SWAP,DROP
  1407. TRAV3    rts
  1408.  
  1409.     WORDMX 6,LATES,T
  1410. LATEST    DO2    CURENT,AT
  1411.     DOX    AT
  1412.  
  1413.     WORDMX 3,LF,A
  1414. LFA    DO1    WLITER
  1415.     dc.w    10
  1416.     DOX    SUB
  1417.  
  1418.     WORDMX 3,CF,A
  1419. CFA    DO1    WLITER
  1420.     dc.w    6
  1421.     DOX    SUB
  1422.  
  1423.     WORDMX 3,NF,A
  1424. NFA    DO1    WLITER
  1425.     dc.w    11            ; 6 byte cf, 4 byte lf
  1426.     DO4    SUB,DUP,CAT,WLITER
  1427.     dc.w    $80
  1428.     DO2    LESS,ZBRAN
  1429.     dc.w    NFA10-START
  1430.     DO1    ONEM
  1431. NFA10    DO2    ONE,MINUS
  1432.     DOX    TRAV
  1433.  
  1434.     WORDMX 3,PF,A
  1435. PFA    DO5    ONE,TRAV,ONEP,WALLIGN,WLITER
  1436.     dc.w    10
  1437.     DOX    PLUS
  1438.  
  1439.     WORDMX 4,!CS,P
  1440. SCSP    DO2    SPAT,CSP
  1441.     DOX    STORE
  1442.  
  1443.     WORDMX 6,?ERRO,R
  1444. QERR    DO2    SWAP,ZBRAN
  1445.     dc.w    QERR2-START
  1446.     DO2    ERROR,BRAN
  1447.     dc.w    QERR3-START
  1448. QERR2    addq.l #4,a6
  1449. QERR3    rts
  1450.  
  1451.     WORDMX 5,?COM,P
  1452. QCOMP    DO4    STATE,AT,ZEQU,WLITER
  1453.     dc.w    $11
  1454.     DOX    QERR
  1455.  
  1456.     WORDMX 5,?EXE,C
  1457. QEXEC    DO3    STATE,AT,WLITER
  1458.     dc.w    $12
  1459.     DOX    QERR
  1460.  
  1461.     WORDMX 6,?PAIR,S
  1462. QPAIRS    DO2    SUB,WLITER
  1463.     dc.w    $13
  1464.     DOX    QERR
  1465.  
  1466.     WORDMX 4,?CS,P
  1467. QCSP    DO5    SPAT,CSP,AT,SUB,WLITER
  1468.     dc.w    $14
  1469.     DOX    QERR
  1470.  
  1471.     WORDMX 8,?LOADIN,G
  1472. QLOAD    DO4    BLK,AT,ZEQU,WLITER
  1473.     dc.w    $16
  1474.     DOX    QERR
  1475.  
  1476.     WORDMX 6,?STAC,K
  1477. QSTACK    DO7    SPAT,SZERO,AT,SWAP,LESS,ONE,QERR
  1478.     DO3    SPAT,HERE,WLITER
  1479.     dc.w    128            ; want 128 spaces higher than dict
  1480.     DO4    PLUS,LESS,TWO,QERR     ; full stack
  1481.     rts
  1482.  
  1483.     WORDMX 7,COMPIL,E
  1484. COMPIL    DO5    QCOMP,FROMR,DUP,WAT,WLITER
  1485.     dc.w    $4eb9
  1486.     DO2    EQUAL,ZBRAN
  1487.     dc.w    COMPIL1-START
  1488.     DO1    WLITER
  1489.     dc.w    $4eb9
  1490.     DO7    WCOMM,TWOP,DUP,AT,COMMA,FOURP,BRAN
  1491.     dc.w    COMPIL2-START
  1492. COMPIL1    DO1    WLITER
  1493.     dc.w    $4ead
  1494.     DO6    WCOMM,TWOP,DUP,WAT,WCOMM,TWOP
  1495. COMPIL2    DOX    EXEC
  1496.  
  1497.  
  1498.     WORDMI1 1,,[
  1499. LBRAK    DO2    ZERO,STATE
  1500.     DOX    STORE
  1501.  
  1502.     WORDM1 1,,]
  1503. RBRAK    DO1    WLITER
  1504.     dc.w    $C0
  1505.     DO1    STATE
  1506.     DOX    STORE
  1507.  
  1508.     WORDMX 3,HE,X
  1509. HEX    DO1    WLITER
  1510.     dc.w    16
  1511.     DO1    BASE
  1512.     DOX    STORE
  1513.  
  1514.     WORDMX 7,DECIMA,L
  1515. DEC    DO1    WLITER
  1516.     dc.w    10
  1517.     DO1    BASE
  1518.     DOX    STORE
  1519.  
  1520.     WORDMX 7,(;CODE,)
  1521. PSCODE    move.l    (a7)+,-(a6)
  1522.     DO4    LATEST,PFA,CFA,TWOP    ; 2+ moves past JSR opcode in CFA
  1523.     DOX    STORE            ; fix Absolute address of JSR
  1524.  
  1525.     WORDMIX 5,;COD,E
  1526. SEMIC    DO5    QCSP,COMPIL,PSCODE,LBRAK,QSTACK
  1527. ; NOTE: QSTACK is replaced by ASSEMBLER in versions with one.
  1528.  
  1529.     WORDMX 5,COUN,T
  1530. COUNT    DO3    DUP,ONEP,SWAP
  1531.     DOX    CAT
  1532.  
  1533.     WORDMX 4,TYP,E
  1534. TYPE    DO2    DDUP,ZBRAN
  1535.     dc.w    TYPE3-START
  1536.     DO4    OVER,PLUS,SWAP,XDO
  1537. TYPE2    DO4    I,CAT,EMIT,XLOOP
  1538.     dc.w    TYPE2-START
  1539.     DO1    BRAN
  1540.     dc.w    TYPE4-START
  1541. TYPE3    addq.l #4,a6 drop
  1542. TYPE4    rts
  1543.  
  1544.     WORDMX 9,-TRAILIN,G
  1545. DTRAIL    DO3    DUP,ZERO,XDO
  1546. DTRAL2    DO7    OVER,OVER,PLUS,ONE,SUB,CAT,BL
  1547.     DO2    SUB,ZBRAN
  1548.     dc.w    DTRAL3-START
  1549.     DO2    LEAVE,BRAN
  1550.     dc.w    DTRAL4-START
  1551. DTRAL3    DO2    ONE,SUB
  1552. DTRAL4    DO1    XLOOP
  1553.     dc.w    DTRAL2-START
  1554.     rts
  1555.  
  1556.     WORDMI1 1,,"
  1557. QUOTE    DO1    WLITER
  1558.     dc.w    $22 quote
  1559.     DO3    STATE,AT,ZBRAN
  1560.     dc.w    QUOTE1-START
  1561.     DO9    COMPIL,PQUOTE,WORD,HERE,CAT,ONEP,WALLIGN,ALLOT,BRAN
  1562.     dc.w    QUOTE2-START
  1563. QUOTE1    DO9    WORD,HERE,HERE,CAT,ONEP,PAD,SWAP,CMOVE,PAD
  1564. QUOTE2    rts
  1565.  
  1566. ;    WORDMX 3,(",)
  1567.     dc.b    $80+3,'(','"',$80+')'
  1568.     dc.l    $ad55ad55
  1569. PQUOTE    DO8    R,DUP,CAT,ONEP,FROMR,PLUS,WALLIGN,TOR
  1570.     rts
  1571.  
  1572. ;    WORDMX 4,(.",)
  1573.     dc.b    $80+3,"(.",'"',$80+')'
  1574.     dc.l    $ad55ad55
  1575. PDOTQ    DO8    R,COUNT,DUP,ONEP,FROMR,PLUS,WALLIGN,TOR
  1576.     DOX    TYPE
  1577.  
  1578.     WORDMIX 2,.,"
  1579. DOTQ    DO1    WLITER
  1580.     dc.w    $22 quote
  1581.     DO3    STATE,AT,ZBRAN
  1582.     dc.w    DOTQ1-START
  1583.     DO9    COMPIL,PDOTQ,WORD,HERE,CAT,ONEP,WALLIGN,ALLOT,BRAN
  1584.     dc.w    DOTQ2-START
  1585. DOTQ1    DO4    WORD,HERE,COUNT,TYPE
  1586. DOTQ2    rts
  1587.  
  1588.     WORDMX 6,EXPEC,T
  1589. EXPECT    DO4    OVER,PLUS,OVER,XDO
  1590. EXPEC2    DO3    KEY,DUP,WLITER
  1591.     dc.W    $08
  1592.     DO2    EQUAL,ZBRAN
  1593.     dc.w    EXPEC3-START
  1594.     addq.l #4,a6 drop
  1595.     DO1    WLITER
  1596.     dc.W    $08
  1597.     DO4    OVER,I,EQUAL,DUP
  1598.     DO7    FROMR,TWO,SUB,PLUS,TOR,SUB,BRAN
  1599.     dc.w    EXPEC6-START
  1600. EXPEC3    DO2    DUP,WLITER
  1601.     dc.w    $0D            ; (Carriage Return)
  1602.     DO2    EQUAL,ZBRAN
  1603.     dc.w    EXPEC4-START
  1604.     DO1    LEAVE
  1605.     addq.l #4,a6 drop
  1606.     DO3    BL,ZERO,BRAN
  1607.     dc.w     EXPEC5-START
  1608. EXPEC4    DO2    DUP,WLITER
  1609.     dc.w    $09            ; tab
  1610.     DO2    EQUAL,ZBRAN
  1611.     dc.w    EXPEC1-START
  1612.     DO2    BL,BRAN
  1613.     dc.w    EXPEC5-START
  1614. EXPEC1    DO1    DUP
  1615. EXPEC5    DO6    I,CSTORE,ZERO,I,ONEP,CSTORE
  1616. EXPEC6    DO3    QUIET,AT,ZBRAN        ; no echo if in quiet mode
  1617.     dc.w    EXPEC7-START
  1618.     addq.l #4,a6            ; drop character
  1619.     DO1    BRAN
  1620.     dc.w    EXPEC8-START
  1621. EXPEC7    DO1    EMIT
  1622. EXPEC8    DO1    XLOOP
  1623.     dc.w    EXPEC2-START
  1624.     addq.l #4,a6 drop
  1625.     rts
  1626.  
  1627.     WORDMX 5,QUER,Y
  1628. QUERY    DO7    TIB,AT,COLUMS,AT,EXPECT,ZERO,IN
  1629.     DOX    STORE
  1630.  
  1631. ;    WORDM1 1,,
  1632.     dc.b    $C1        ; IMMEDIATE
  1633.     dc.b    $80        ; ( NULL)
  1634.     dc.l    $ad55ad55
  1635. ;ENDM
  1636. NULL    DO3    BLK,AT,ZBRAN
  1637.     dc.w    NULL2-START
  1638.     DO9    ONE,BLK,PSTORE,ZERO,IN,STORE,BLK,AT,BSCR
  1639. ;    check for end of screen
  1640.     DO3    MOD,ZEQU,ZBRAN
  1641.     dc.w    NULL1-START
  1642.     DO2    QEXEC,FROMR
  1643.     addq.l #4,a6 drop
  1644. NULL1    DO1    BRAN
  1645.     dc.w    NULL3-START
  1646. NULL2    DO1    FROMR
  1647.     addq.l #4,a6 drop
  1648. NULL3    rts
  1649.  
  1650.     WORDMX 4,FIL,L
  1651. FILL    DO9    SWAP,TOR,OVER,CSTORE,DUP,ONEP,FROMR,ONE,SUB
  1652.     DOX    CMOVE
  1653.  
  1654.     WORDMX 5,ERAS,E
  1655. ERASE    DO1    ZERO
  1656.     DOX    FILL
  1657.  
  1658.     WORDMX 6,BLANK,S
  1659. BLANKS    DO1    BL
  1660.     DOX    FILL
  1661.  
  1662.     WORDMX 4,HOL,D
  1663. HOLD    DO1    LIT
  1664.     dc.l    -1
  1665.     DO4    HLD,PSTORE,HLD,AT
  1666.     DOX    CSTORE
  1667.  
  1668.     WORDMX 3,PA,D
  1669. PAD    DO2    HERE,WLITER
  1670.     dc.w    $44
  1671.     DOX     PLUS
  1672.  
  1673.     WORDMX 4,WOR,D
  1674. WORD    DO3    BLK,AT,ZBRAN
  1675.     dc.w    WORD2-START
  1676.     DO4    BLK,AT,BLOCK,BRAN
  1677.     dc.w    WORD3-START
  1678. WORD2    DO2    TIB,AT
  1679. WORD3    DO7    IN,AT,PLUS,SWAP,ENCLOS,HERE,WLITER
  1680.     dc.w    34
  1681.     DO9    BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE,CSTORE
  1682.     DO4    PLUS,HERE,ONEP,FROMR
  1683.     DOX    CMOVE
  1684.  
  1685. ;    WORDMI1 1,,'
  1686.     dc.b    $80+1,$80+$27            ; single quote
  1687.     dc.l    $ad55ad55
  1688. TICK    DO4    DFIND,ZEQU,ZERO,QERR
  1689.     addq.l #4,a6 drop
  1690.     DOX    LITER
  1691.  
  1692.     WORDMX 6,FORGE,T
  1693. FORGET    DO6    CURENT,AT,CONTXT,AT,SUB,WLITER
  1694.     dc.w    24
  1695.     DO7    QERR,TICK,DUP,FENCE,AT,LESS,WLITER
  1696.     dc.w    21
  1697.     DO3    QERR,DUP,LIT
  1698.     dc.l    SINIT
  1699.     DO3    AT,GREAT,WLITER
  1700.     dc.w    21
  1701.     DO9    QERR,DUP,NFA,DPTR,STORE,LFA,AT,CONTXT,AT
  1702.     DOX    STORE
  1703.  
  1704.     WORDMX 4,BAC,K
  1705. BACK    DO2    HERE,SUB
  1706.     DOX    WCOMM
  1707.  
  1708.     WORDMIX 5,BEGI,N
  1709. BEGIN    DO2    QCOMP,HERE
  1710.     DOX    ONE
  1711.  
  1712.     WORDMIX 5,ENDI,F
  1713. ENDIF    DO7    QCOMP,TWO,QPAIRS,HERE,OVER,SUB,SWAP
  1714.     DOX    WSTORE
  1715.  
  1716.     WORDMIX    4,THE,N
  1717. THEN    DOX    ENDIF
  1718.  
  1719.     WORDMIX 2,D,O
  1720. DO    DO3    COMPIL,XDO,HERE
  1721.     DOX    THREE
  1722.  
  1723.     WORDMIX    4,LOO,P
  1724. LOOP    DO4    THREE,QPAIRS,COMPIL,FLOOP
  1725.     DOX    BACK
  1726.  
  1727.     WORDMIX 5,+LOO,P
  1728. PLOOP    DO4    THREE,QPAIRS,COMPIL,FPLOOP
  1729.     DOX    BACK
  1730.  
  1731.     WORDMIX 5,UNTI,L
  1732. UNTIL    DO4    ONE,QPAIRS,COMPIL,ZBRANCH
  1733.     DOX    BACK
  1734.  
  1735.     WORDMIX 3,EN,D
  1736. END    DOX    UNTIL
  1737.  
  1738.     WORDMIX 5,AGAI,N
  1739. AGAIN    DO4    ONE,QPAIRS,COMPIL,BRANCH
  1740.     DOX    BACK
  1741.  
  1742.     WORDMIX 6,REPEA,T
  1743. REPEAT    DO7    TOR,TOR,AGAIN,FROMR,FROMR,TWO,SUB
  1744.     DOX    ENDIF
  1745.  
  1746.     WORDMIX 2,I,F
  1747. IF    DO5    COMPIL,ZBRANCH,HERE,ZERO,WCOMM
  1748.     DOX    TWO
  1749.  
  1750.     WORDMIX 4,ELS,E
  1751. ELSE    DO8    TWO,QPAIRS,COMPIL,BRANCH,HERE,ZERO,WCOMM,SWAP
  1752.     DO2    TWO,ENDIF
  1753.     DOX    TWO
  1754.  
  1755.     WORDMIX 5,WHIL,E
  1756. WHILE    DO1    IF
  1757.     DOX    TWOP
  1758.  
  1759.     WORDMIX    4,CAS,E
  1760. CASE    DO5    QCOMP,CSP,AT,SCSP,WLITER
  1761.     dc.w    4
  1762.     rts
  1763.  
  1764.     WORDMIX    2,O,F
  1765. OF    DO8    FOUR,QPAIRS,COMPIL,OVER,COMPIL,EQUAL,COMPIL,ZBRANCH
  1766.     DO6    HERE,ZERO,WCOMM,COMPIL,DROP,WLITER
  1767.     dc.w    5
  1768.     rts
  1769.  
  1770.     WORDMIX    5,ENDO,F
  1771. ENDOF    DO1    WLITER
  1772.     dc.w    5
  1773.     DO6    QPAIRS,COMPIL,BRANCH,HERE,ZERO,WCOMM
  1774.     DO4    SWAP,TWO,ENDIF,FOUR
  1775.     rts
  1776.  
  1777.     WORDMIX    7,ENDCAS,E
  1778. ENDCASE    DO4    FOUR,QPAIRS,COMPIL,DROP
  1779. ENDC10    DO6    SPAT,CSP,AT,EQUAL,ZEQU,ZBRAN
  1780.     dc.w    ENDC20-START
  1781.     DO3    TWO,ENDIF,BRAN
  1782.     dc.w    ENDC10-START
  1783. ENDC20    DO2    CSP,STORE
  1784.     rts
  1785.  
  1786.     WORDMX 6,SPACE,S
  1787. SPACES    DO4    ZERO,MAX,DDUP,ZBRAN
  1788.     dc.w    SPACE3-START
  1789.     DO2    ZERO,XDO
  1790. SPACE2    DO2    SPACE,XLOOP
  1791.     dc.w    SPACE2-START
  1792. SPACE3    rts
  1793.  
  1794.     WORDMX 2,<,#
  1795. BDIGS    DO2    PAD,HLD
  1796.     DOX    STORE
  1797.  
  1798.     WORDMX 2,#,>
  1799. EDIGS    addq.l #4,a6 drop
  1800.     DO4    HLD,AT,PAD,OVER
  1801.     DOX    SUB
  1802.  
  1803.     WORDMX 4,SIG,N
  1804. SIGN    DO3    SWAP,ZLESS,ZBRAN
  1805.     dc.w    SIGN2-START
  1806.     DO1    WLITER
  1807.     dc.w    $2D        ; ASCII '-'
  1808.     DOX    HOLD
  1809. SIGN2    rts
  1810.  
  1811.     WORDM1 1,,#
  1812. DIG
  1813.     DO5    BASE,AT,USLASHM,SWAP,WLITER
  1814.     dc.w    9
  1815.     DO3    OVER,LESS,ZBRAN
  1816.     dc.w    DIG2-START
  1817.     DO1    WLITER
  1818.     dc.w    7
  1819.     DO1    PLUS
  1820. DIG2    DO1    WLITER
  1821.     dc.w    $30        ; ascii zero
  1822.     DO2    PLUS,HOLD
  1823.     rts
  1824.  
  1825.     WORDMX 2,#,S
  1826. DIGS
  1827.     DO4    DIG,DUP,ZEQU,ZBRAN
  1828.     dc.w    DIGS-START
  1829.     rts
  1830.  
  1831.     WORDMX 2,.,R
  1832. DOTR
  1833.     DO6    TOR,DUP,ABS,BDIGS,DIGS,SIGN
  1834.     DO5    EDIGS,FROMR,OVER,SUB,SPACES
  1835.     DOX    TYPE
  1836.  
  1837.     WORDMX 2,U,.
  1838. UDOT    DO1    ZERO
  1839.     DOX    DOTR
  1840.  
  1841.     WORDM1 1,,.
  1842. DOT    DO2    ZERO,DOTR
  1843.     DOX    SPACE
  1844.  
  1845.     WORDM1 1,,?
  1846. QUEST    DO1    AT
  1847.     DOX    DOT
  1848.  
  1849.     WORDMX 2,W,?
  1850. WQUEST    DO1    WAT
  1851.     DOX    DOT
  1852.  
  1853.     WORDMX 2,C,?
  1854. CQUEST    DO1    CAT
  1855.     DOX    DOT
  1856.  
  1857.     WORDMX 8,(NUMBER,)
  1858. PNUMB
  1859. PNUMB1    DO8    ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
  1860.     dc.w    PNUMB4-START
  1861.     DO4    SWAP,BASE,AT,USTAR
  1862.     addq.l #4,a6 drop
  1863.     DO2    ROT,BASE
  1864.     DO7    AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
  1865.     dc.w    PNUMB3-START
  1866.     DO3    ONE,DPL,PSTORE
  1867. PNUMB3    DO2    FROMR,BRAN
  1868.     dc.w    PNUMB1-START
  1869. PNUMB4    DO1    FROMR
  1870.     rts
  1871.  
  1872.     WORDMX 6,NUMBE,R
  1873. NUMB    DO7    ZERO,ZERO,ROT,DUP,ONEP,CAT,WLITER
  1874.     dc.w    $2D            ; minus sign
  1875.     DO5    EQUAL,DUP,TOR,PLUS,LIT
  1876.     dc.l    -1
  1877. NUMB1    DO8    DPL,STORE,PNUMB,DUP,CAT,BL,SUB,ZBRAN
  1878.     dc.w    NUMB2-START
  1879.     DO3    DUP,CAT,WLITER
  1880.     dc.w    $2E
  1881.     DO5    SUB,ZERO,QERR,ZERO,BRAN
  1882.     dc.w    NUMB1-START
  1883. NUMB2    addq.l #4,a6 drop
  1884.     DO2    FROMR,ZBRAN
  1885.     dc.w    NUMB3-START
  1886.     DOX    DMINUS
  1887. NUMB3
  1888.     rts
  1889.  
  1890.     WORDMX 5,-FIN,D
  1891. DFIND    DO9    BL,WORD,HERE,CONTXT,AT,AT,PFIND,DUP,ZEQU
  1892.     DO1    ZBRAN
  1893.     dc.w    DFIND2-START
  1894.     addq.l #4,a6 drop
  1895.     DO3    HERE,LATEST,PFIND
  1896. DFIND2    rts
  1897.  
  1898.     WORDMX 7,(ABORT,)
  1899. PABORT    DOX    ABORT
  1900.  
  1901.     WORDMX 5,ERRO,R
  1902. ERROR    DO4    WARN,AT,ZLESS,ZBRAN
  1903. ; WARNING is -1 to abort, 0 to print error #, and >1 to pring
  1904. ;          error message from the message SCReen on disc
  1905.     dc.w    ERROR2-START
  1906.     DO1    PABORT
  1907. ERROR2    DO4    HERE,COUNT,TYPE,PDOTQ
  1908.     dc.b    3," ? "
  1909.     DO2    MESS,SPSTOR
  1910.     DOX    QUIT
  1911.  
  1912.     WORDMX 3,ID,.
  1913. IDDOT    DO3    DUP,CAT,WLITER
  1914.     dc.w    $1F
  1915.     DO3    AND,ZERO,XDO
  1916. IDDOT1    DO4    ONEP,DUP,CAT,WLITER
  1917.     dc.w    $7F
  1918.     DO3    AND,EMIT,XLOOP
  1919.     dc.w    IDDOT1-START
  1920.     addq.l #4,a6 drop
  1921.     rts
  1922.  
  1923.     WORDMX 6,CREAT,E
  1924. CREATE    DO2    DFIND,ZBRAN
  1925.     dc.w    CREAT2-START
  1926.     addq.l #4,a6 drop
  1927.     DO1    PDOTQ
  1928.     dc.b    11,"redefined: "
  1929.     DO3    NFA,IDDOT,WLITER
  1930.     dc.w    4
  1931.     DO2    MESS,SPACE
  1932. CREAT2    DO6    HERE,DUP,DUP,CAT,OVER,WLITER
  1933.     dc.w    $80
  1934.     DO5    TOGGLE,DUP,ROT,PLUS,WLITER
  1935.     dc.w    $80
  1936.     DO4    TOGGLE,ONEP,WALLIGN,ALLOT
  1937.     DO7    LATEST,COMMA,CURENT,AT,STORE,HERE,WLITER
  1938.     dc.w    $4eB9        ; JSR code
  1939.     DO5    WCOMM,THREE,PLUS,THREE,PLUS
  1940.     DOX    COMMA
  1941.  
  1942.     WORDMIX 9,[COMPILE,]
  1943. BCOMP    DO4    DFIND,ZEQU,ZERO,QERR
  1944.     addq.l #4,a6 drop
  1945.     DO2    CFA,WLITER
  1946.     dc.w    $4eB9            PUT IN 'JSR' FIRST
  1947.     DO1    WCOMM
  1948.     DOX    COMMA
  1949.  
  1950.     WORDMIX 7,LITERA,L
  1951. LITER    DO3    STATE,AT,ZBRAN
  1952.     dc.w    LITER2-START
  1953.     DO3    COMPIL,LIT,COMMA
  1954. LITER2    rts
  1955.  
  1956.     WORDMIX 8,DLITERA,L
  1957. DLITER    DO3    STATE,AT,ZBRAN
  1958.     dc.w    DLITE2-START
  1959.     DO3    COMPIL,LIT,COMMA
  1960. DLITE2    rts
  1961.  
  1962.     WORDMX 9,INTERPRE,T
  1963. INTERP    DO2    DFIND,ZBRAN
  1964.     dc.w    INTER5-START
  1965.  
  1966.     DO4    DUP,STATE,AT,LESS
  1967.     DO1    ZBRAN
  1968.     dc.w    INTER3-START
  1969.  
  1970.     DO1    WLITER
  1971.     dc.w    $a0
  1972.     DO2    LESS,ZBRAN
  1973.     dc.w    INTER1-START
  1974.  
  1975.     DO2    CFA,WLITER
  1976.     dc.w    $4eb9        INSERT JSR PREFIX
  1977.     DO3    WCOMM,COMMA,BRAN
  1978.     dc.w    INTER4-START
  1979.  
  1980. INTER1    DO1    CFA
  1981.  
  1982. INTER2    DO3    DUP,WAT,WLITER
  1983.     dc.w    $4e75        ; RTS code
  1984.     DO2    SUB,ZBRAN
  1985.     dc.w    INTER21-START
  1986.  
  1987.     DO5    DUP,WAT,WCOMM,TWOP,BRAN
  1988.     dc.w    INTER2-START
  1989.  
  1990. INTER21    addq.l #4,a6 drop
  1991.     DO1    BRAN
  1992.     dc.w    INTER4-START
  1993.  
  1994. INTER3    addq.l #4,a6 drop
  1995.     DO2    CFA,EXEC
  1996.  
  1997. INTER4    DO2    QSTACK,BRAN
  1998.     dc.w    INTER7-START
  1999.  
  2000. INTER5    DO6    HERE,NUMB,DPL,AT,ONEP,ZBRAN
  2001.     dc.w    INTER6-START
  2002.  
  2003.     DO2    DLITER,BRAN
  2004.     dc.w    INTER7-START
  2005.  
  2006. INTER6    addq.l #4,a6 drop
  2007.     DO1    LITER
  2008.  
  2009. INTER7    DO2    QSTACK,BRAN
  2010.     dc.w    INTERP-START
  2011.  
  2012.     WORDMX 9,IMMEDIAT,E
  2013. IMMED    DO2    LATEST,WLITER
  2014.     dc.w    $40
  2015.     DOX    TOGGLE
  2016.  
  2017.     WORDMX 5,MACR,O
  2018. MACR    DO2    LATEST,WLITER
  2019.     dc.w    $20
  2020.     DOX    TOGGLE
  2021.  
  2022.     WORDMX 10,VOCABULAR,Y
  2023. VOCAB    DO2    BUILDS,WLITER
  2024.     dc.w    $81A0
  2025.     DO5    WCOMM,CURENT,AT,TWOM,COMMA
  2026.     DO7    HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
  2027. DOVOC    DO2    TWOP,CONTXT
  2028.     DOX    STORE
  2029.  
  2030.     WORDMX 11,DEFINITION,S
  2031. DEFIN    DO3    CONTXT,AT,CURENT
  2032.     DOX    STORE
  2033.  
  2034.     WORDMI1 1,,(
  2035. PAREN    DO1    WLITER
  2036.     dc.w    $29        ; ASCII '('
  2037.     DOX    WORD
  2038.  
  2039.     WORDMX 4,DUM,P
  2040. DUMP    DO4    OVER,PLUS,SWAP,XDO
  2041. DUMP1    DO6    I,CR,HEX,UDOT,I,WLITER
  2042.     dc.w    16
  2043.     DO3    PLUS,I,XDO
  2044. DUMP2    DO6    SPACE,I,CAT,TWO,DOTR,XLOOP
  2045.     dc.w    DUMP2-START
  2046.     DO4    THREE,SPACES,I,WLITER
  2047.     dc.w    16
  2048.     DO3    PLUS,I,XDO
  2049. DUMP3    DO3    I,CAT,WLITER
  2050.     dc.w    $7F         MASK MSB
  2051.     DO3    AND,DUP,WLITER
  2052.     dc.w    $20
  2053.     DO2    LESS,ZBRAN
  2054.     dc.w    DUMP31-START
  2055.     addq.l #4,a6 drop
  2056.     DO1    WLITER
  2057.     dc.w    $5F        ; ASCII '_'
  2058. DUMP31    DO2    EMIT,XLOOP
  2059.     dc.w    DUMP3-START
  2060.     DO1    WLITER
  2061.     dc.w    16
  2062.     DO1    XPLOOP
  2063.     dc.w    DUMP1-START
  2064.     rts
  2065.  
  2066.     WORDMX 5,VLIS,T
  2067. VLIST    DO1    WLITER
  2068.     dc.w    $80
  2069.     DO5    OUT,STORE,CONTXT,AT,AT
  2070. VLIST1    DO5    OUT,AT,COLUMS,AT,WLITER
  2071.     dc.w    16
  2072.     DO3    SUB,GREAT,ZBRAN
  2073.     dc.w    VLIST2-START
  2074.     DO4    CR,ZERO,OUT,STORE
  2075. VLIST2    DO9    DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT,DUP,ZEQU
  2076.     DO3    QTERM,OR,ZBRAN
  2077.     dc.w    VLIST1-START
  2078.     addq.l #4,a6  drop
  2079.     rts
  2080.  
  2081.     WORDMX 4,QUI,T
  2082. QUIT    DO4    ZERO,BLK,STORE,LBRAK
  2083.  
  2084. ;
  2085. ; Here is outer interpreter which gets line of input, does it,
  2086. ; and then prints " OK" and repeats.
  2087. ;
  2088.  
  2089. QUIT2    DO5    RPSTOR,QUIET,AT,ZEQU,ZBRAN
  2090.     dc.w    QUIT4-START            ; no CR if in quiet mode
  2091.     DO1    CR
  2092.  
  2093. QUIT4    DO6    QUERY,INTERP,STATE,AT,ZEQU,ZBRAN
  2094.     dc.w    QUIT3-START
  2095.  
  2096.     DO4    QUIET,AT,ZEQU,ZBRAN        ; no "OK" if in quiet mode
  2097.     dc.w    QUIT3-START
  2098.  
  2099.     DO1    PDOTQ
  2100.     dc.b    3," OK"
  2101.     DO7    SPAT,SZERO,AT,SWAP,SUB,FOUR,SLASH
  2102.     DO2    SPACE,DOT            ; print stack depth
  2103. QUIT3    DO1    BRAN
  2104.     dc.w    QUIT2-START
  2105.  
  2106.     WORDMX 5,ABOR,T
  2107. ABORT    DO5    SPSTOR,DEC,DRZERO,CR,PDOTQ
  2108.     dc.b    21,"Sforth68k Version 1.0"
  2109.     DO6    ZERO,IN,STORE,ZERO,BLK,STORE
  2110.     jsr    FORTH
  2111.     DO1    DEFIN
  2112.     DOX    QUIT
  2113. ;
  2114.  
  2115. ;    insert disk words here
  2116.  
  2117.     WORDMX 7,MESSAG,E
  2118. MESS
  2119. MESS3    DO1    PDOTQ
  2120.     dc.b    6,"Error "
  2121.     DO1    WLITER
  2122.     dc.w    $23            ; ASCII '#'
  2123.     DO3    BASE,AT,WLITER
  2124.      dc.w    10            ; DECIMAL
  2125.     DO3    EQUAL,ZEQU,PLUS        ; if = 10, add 0, if 16, add 1 to MAKE '$
  2126.     DO2    EMIT,SPACE
  2127.     DOX    DOT
  2128. MESS4    rts
  2129.  
  2130. BLOCK    RTS
  2131. BSCR    RTS
  2132. DRZERO    RTS
  2133. ;
  2134.     WORDMX 4,NOO,P
  2135. NOOP    rts
  2136.  
  2137. ;
  2138. ; Here is stuff which gets copied to ram
  2139. ; in user dictionary space
  2140. ;
  2141.  
  2142. RAM    dc.b    $C5,"FORT",$80+'H'    ; 5,FORT,H IMMEDIATE
  2143.     dc.l    NOOP-10            ; LINK "BACK" (NFA of NOOP)
  2144. RFORTH    DO1    DODOES
  2145.     dc.l    DOVOC
  2146.     dc.w    $81A0
  2147.     dc.l    TASKAA
  2148.     dc.w    0
  2149.  
  2150.     dc.b    $84,"TAS",$80+'K'    ; 4,TAS,K
  2151.     dc.l    FORTHS            ; link "back" to FORTH
  2152. RTASK    rts
  2153. ERAM
  2154.  
  2155. ;
  2156. ;                   FORTH I/O DRIVERS
  2157. ;
  2158. ;
  2159. ;    THE NEXT WORDS ARE SYSTEM-DEPENDANT I/O SUBROUTINES
  2160. ;
  2161. ;
  2162. ;
  2163. ;    NOW JUMP VECTORS FOR FORTH--3 BYTES EACH
  2164. ;
  2165.  
  2166. PMON    BRA    PPMON    Warmstart MON68K
  2167. PEMIT    BRA    PPEMIT    emit char in d0.b to terminal
  2168. PKEY    BRA    PPKEY    get char from terminal in d0.b (NO ECHO)
  2169. PQTER    BRA    PPQTER    query terminal to see if char typed--
  2170. UCOLD    RTS    NAUGHT    user cold start vector
  2171. UWARM    RTS    NAUGHT    user warm start vector
  2172.  
  2173. ;
  2174. ;    These i/o routines are for a signetics 2681
  2175. ;
  2176.  
  2177. tdre    equ    2
  2178. sroffs    equ    1        offset to status register
  2179. rdroffs    equ    3        offset to rx data register
  2180. tdroffs    equ    3        offset to tx data register
  2181. serport    equ    $20000
  2182. rdrf    equ    0        rdrf bit # in s2681
  2183. rdrfmsk    equ    1        rdrf mask
  2184.  
  2185. * wait for character in acia
  2186.     
  2187. PPKEY    move.l    a1,-(sp)
  2188.     movea.l    #serport,a1    point to serport
  2189.     clr.l    d0        clean start
  2190.  
  2191. PPKEY1    btst    #rdrf,sroffs(a1) rdrf?
  2192.     beq.s    PPKEY1        not yet
  2193.     move.b    rdroffs(a1),d0    yes. get character
  2194.     move.l    (sp)+,a1
  2195.     rts
  2196.  
  2197.  
  2198. * test for character waiting
  2199.  
  2200. PPQTER    move.l    a1,-(sp)
  2201.     movea.l    #serport,a1    point to serport
  2202.     move.b    sroffs(a1),d0
  2203.     andi.l    #rdrfmsk,d0    rdrf?
  2204.     beq.s    PPQTER1        ; if not
  2205.     move.b    rdroffs(a1),d0    return with character
  2206.  
  2207. PPQTER1    move.l    (sp)+,a1
  2208.     rts
  2209.  
  2210. PPEMIT    move.l    a1,-(sp)
  2211.     movea.l    #serport,a1
  2212.     bsr.s    PPEMIT1        transmit char
  2213.     move.l    (sp)+,a1
  2214.     rts
  2215.     
  2216. PPEMIT1    btst    #tdre,sroffs(a1) tdre?
  2217.     beq.s    PPEMIT1        no
  2218.     move.b    d0,tdroffs(a1)    yes, put char in tdr
  2219.     rts
  2220.  
  2221. PPMON    move.l    $4,a0
  2222.     jmp    (a0)
  2223.  
  2224.  
  2225.     END